perm filename MATCH[PAT,LMM] blob
sn#095295 filedate 1974-04-04 generic text, type T, neo UTF8
(FILECREATED " 4-APR-74 22:15:29" MATCH
changes to: 'MATCHSUBPAT, 'MATCHWM, 'MATCHWMFUNARG, 'MATCHELT1, MATCHFNS,
PATAPPLY*
previous date: " 4-APR-74 19:05:19")
(LISPXPRINT (QUOTE MATCHVARS)
T)
[RPAQQ MATCHVARS
((FNS MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 'MATCHWMFUNARG
CHECKSETQ 'MATCHELT1 'MATCHELT PATAPPLY*)
(FNS PATPARSE PATPARSE1 PARSEDEFAULT PATUNPACK PATUNPACKINFIX
PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT
PACKLDIFF)
(FNS SKIP$I SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT
CANMATCHNIL CANMATCHNILLIST REPLACEIN REPLACED)
(FNS EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML MAKESUBST
MAKESUBST3 MAKESUBST0 MAKESUBST1 DOSUBST DOSUBST1 FORMEXPAND
POSTPONEDREPLACE POSTPONEDSETQ SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP PATNARGS UNCDR
CHECKEASYVAR)
(FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'REPLACE
'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 'LAST 'F/L
'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR 'PROGN 'LISTP)
(FNS PATERR PATHELP LOOKLIST VALUELOOKUP LOOK VARCHECK TRUE)
(FNS CHECKSLISTP EQUALUNCROP PATUNPACKINFIX1)
(BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM
'MATCHWMFUNARG CHECKSETQ 'MATCHELT1 'MATCHELT
PATPARSE PATPARSE1 PARSEDEFAULT PATUNPACK
PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT
MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF SKIP$I
SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT?
NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN
REPLACED EASYTORECOMPUTE TEST# NEVERNIL
FULLEXPANSION GENSYML MAKESUBST MAKESUBST0
MAKESUBST3 MAKESUBST1 DOSUBST DOSUBST1 FORMEXPAND
POSTPONEDREPLACE POSTPONEDSETQ SUBSTVAR BOUNDVAR
BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH
UNCROP PATNARGS UNCDR CHECKEASYVAR 'NLEFT 'NOT
'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH
'EQUAL 'LAST 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG
'NCONC 'FOR 'PROGN 'LISTP PATERR PATHELP LOOKLIST
LOOK VALUELOOKUP VARCHECK TRUE PATUNPACKINFIX1
EQUALUNCROP CHECKSLISTP (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS CRLIST MAXCDDDDRS
PATNONNILFUNCTIONS PATGENSYMVARS
PATTERNITEMS PATTERNPREFIXES
PATTERNREPLACEOPRS PATTERNINFIXES
PATTERNINFIXES1 PATTERNCHARRAY
NEVERNILFUNCTIONS MATCHSTATS)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME
CHECKINGLENGTH WMLST
LASTEFFECTCANBENIL
POSTPONEDEFFECTS MUSTRETURN
BINDINGS GENSYMVARLIST SKIPEDLEN
ZLENFLG LOCALDECLARATION
MATCHEXPRESSION MATCHEFFECTS
CHECKLENGTH #LIST PATVARSNILLOOKED
PATVARSNIL POSTPONEDRPLACS
LISTPCHECK DEFAULTLST VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
(BLKAPPLYFNS TRUE 'MATCHWMFUNARG)))
(VARS PATCHARS PATTERNINFIXES PATTERNINFIXES1 PATTERNREPLACEOPRS
PATTERNITEMS PATTERNPREFIXES CRLIST NEVERNILFUNCTIONS
PATNONNILFUNCTIONS [PATTERNCHARRAY
(MAKEBITTABLE (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS (QUOTE CAR]
PATGENSYMVARS)
(P (OR (NEQ (CAR (QUOTE MATCHSTATS))
(QUOTE NOBIND))
(SETQ MATCHSTATS)))
(VARS PATVARDEFAULT MAXCDDDDRS (PATCHECKLENGTH T)
(PATLISTPCHECK NIL)
(PATVARSMIGHTBENIL T]
(DEFINEQ
(MAKEMATCH
[LAMBDA (MATCHEXPRESSION PATTERN)
(LISPXWATCH MATCHSTATS)
(PROG (#LIST BINDINGS SUBLIST (GENSYMVARLIST PATGENSYMVARS)
MATCHEFFECTS
(LOCALDECLARATION (GETLOCALDEC EXPR FAULTFN))
LISTPCHECK VARDEFAULT CHECKLENGTH PATVARSNIL PATVARSNILLOOKED)
(SETQ CLISPCHANGE T)
(SETQ CHECKLENGTH (VALUELOOKUP (QUOTE PATCHECKLENGTH)))
(SETQ LISTPCHECK (VALUELOOKUP (QUOTE PATLISTPCHECK)))
(SETQ VARDEFAULT (VALUELOOKUP (QUOTE PATVARDEFAULT)))
[COND
(PATTERN (SETQ MATCHEXPRESSION (LIST (QUOTE match)
MATCHEXPRESSION
(QUOTE with)
PATTERN]
(SETQ MATCHEXPRESSION
(SELECTQ (CAR MATCHEXPRESSION)
((match MATCH)
[SELECTQ (CADDR MATCHEXPRESSION)
((with WITH))
(COND
((FIXSPELL (CADDR MATCHEXPRESSION)
70
(QUOTE (WITH with))
T
(CDDR MATCHEXPRESSION)))
((LISTP (CADDR MATCHEXPRESSION))
(/ATTACH (QUOTE with)
(CDDR MATCHEXPRESSION)))
(T (PATERR (QUOTE NOWITH)
(CDDR MATCHEXPRESSION]
('MATCHTOP (CADR MATCHEXPRESSION)
(PROG ((TOPPAT (CADDDR MATCHEXPRESSION)))
(PATPARSE TOPPAT))
[AND (CDDDDR MATCHEXPRESSION)
(PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY1B (CDR (CDDDDR
MATCHEXPRESSION))
MATCHEXPRESSION T NIL
NIL FAULTFN)
(RETURN (CDR (CDDDDR
MATCHEXPRESSION]
(EQ (CAR (CDDDDR MATCHEXPRESSION))
(QUOTE ->))
T))
(HELP)))
(RETURN (COND
[BINDINGS ('PROG BINDINGS (LIST (LIST (QUOTE RETURN)
MATCHEXPRESSION]
(T MATCHEXPRESSION])
('MATCHTOP
[LAMBDA (VAR PAT CONSTRUCT SMASHFLG RETURNFLG)
(PROG (POSTPONEDRPLACS POSTPONEDEFFECTS LASTEFFECTCANBENIL MUSTRETURN WMLST
WATCHPOSTPONELST SUBLIST SAVEDUMMY)
(* POSTPONEDEFFECTS is the list of side effects postponed -
LASTEFFECTCANBENIL is a flag which should be set whenever a
side effect is postponed (used for determining whether the
extra T at the end is necessary) -
BINDINGS will be list of prog bindings that need to be done
-
MUSTRETURN will be the * expression, if any)
(* CHECKINGLENGTH is the flag whether the length should be
checked (used for example in (-- 'A & &) already done the
NLEFT which implicitly checks) -
-
INASOME is a flag that says that we are, at this level,
after a -- type pattern, so that if another -- is
encountered, just reset INASOME to the match expression for
what comes after the second --;
this is so (-- A -- B --) will generate
(MEMB 'B (MEMB 'A X)) instead of
(SOME X (F/L (Z) (Z:1='A AND 'B MEMB Z::1))) -
WMLST is a stack used by *GLITCH for remembering when a !
(SUBPAT --) is encountered to expand it, but remember the
tail after the !SUBPAT and return
(by RPLAC'ing into the corresponding entry in WMLIST) the
expression for "WHAT MATCHED" -
SUBLIST is the list where substitutions in the final pattern
are collected)
(* WATCHPOSTPONELST is a list of those vars which, when a
POSTPONE involving them is encountered, the corresponding
entry in WATCHPOSTPONELST should be rplac'ed)
(SETQ VAR (CHECKEASYVAR (COPY VAR)
PAT))
(SETQ MATCHEXPRESSION ('MATCHSUBPAT VAR PAT))
(SETQ SUBLIST (DREVERSE SUBLIST))
[AND CONSTRUCT SMASHFLG (SETQ CONSTRUCT (LIST (SETQ SAVEDUMMY
(CONS (QUOTE DUMMY)
(CONS VAR
CONSTRUCT]
[SETQ MATCHEFFECTS (NCONC (DREVERSE POSTPONEDEFFECTS)
(DREVERSE POSTPONEDRPLACS)
(COND
(CONSTRUCT)
(MUSTRETURN (LIST MUSTRETURN))
((AND LASTEFFECTCANBENIL (NULL
POSTPONEDRPLACS))
(LIST T]
(RETURN (PROG1 [DOSUBST (COND
(RETURNFLG ('AND MATCHEXPRESSION
('PROGN MATCHEFFECTS)))
(T (CONS MATCHEXPRESSION MATCHEFFECTS]
(AND SAVEDUMMY (RPLNODE2 SAVEDUMMY
('REPLACE
(CADR SAVEDUMMY)
('PROGN (CDDR SAVEDUMMY])
('MATCHSUBPAT
[LAMBDA (VAR PATELT NOLISTPCHECK)
(PROG ((CHECKINGLENGTH T)
INASOME)
(COND
((AND LISTPCHECK (NOT NOLISTPCHECK))
('AND ('LISTP VAR)
('MATCHWM VAR PATELT NIL)))
(T ('MATCHWM VAR PATELT NIL])
('MATCHWM
[LAMBDA (VAR PAT FN)
(* Creates an expression which will return non-NIL if and
only if the value of the VAR expression will match the
parsed pattern PAT, and the expression generated by applying
(CAR FN) to (the expression giving What-Matched the first
pattern element of PAT) and (CDR FN) -
is non-nil as well. FN can hide side effects as well i.e. FN
may say to generate a side effect to be executed if the
entire pattern succeeds)
(PROG (TEM1 TEM2 TAIL ZLENFLG (SKIPEDLEN 0))
(* ZLENFLG and SKIPEDLEN are set
from within SKIP$I and SKIP$ANY)
(COND
[(NULL PAT)
(RETURN (OR (NOT CHECKLENGTH)
(NOT CHECKINGLENGTH)
('NULL VAR]
[(NLISTP (CAR PAT))
(* The only NLISTP patterns are &, $, --, NIL, T, strings
and numbers)
(SELECTQ
(CAR PAT)
[($ --)
(RETURN
(COND
((NULL (CDR PAT)) (* Pattern ends in $ -
What matched is the whole thing)
(PATAPPLY* FN VAR))
(INASOME
(* We are within a tail which began with -- or $;
thus, we should not return the match here but instead, SET
the variable INASOME to the match expression here and return
T -
since there is no point in checking this match expression
repeatedly)
(COND
((LISTP INASOME)
(PATHELP "INASOME mismatch")))
[DOWATCH (SETQ INASOME
(PROG (INASOME)
('MATCHWM VAR PAT FN]
T)
[(ARB? (CADR PAT))
(COND
((OR (SKIP$ANY (CDDR PAT))
(NOT (ZEROP SKIPEDLEN)))
(* ($ ARB -- }FIXED) I.e. two arb's in a row, followed by
something)
(PATERR "Two arbitrary segments in a row")))
(* Must mean the second is LAST)
('AND ('MATCHWM (SETQ TEM1 (SUBSTVAR ('LAST VAR)))
(CDR PAT)
NIL)
(PATAPPLY* FN ('LDIFF VAR TEM1]
[[AND (NULL FN)
(PROGN (SETQ TAIL (SKIP$I (CDR PAT)))
(NOT (ZEROP SKIPEDLEN]
(* Special check here, since might have
(... -- $4) or not need any 'NLEFT's)
(COND
((OR (NULL TAIL)
(NULLPAT? TAIL))
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH VAR SKIPEDLEN)))
((NUMBERP SKIPEDLEN)
('MATCHWM ('NTH VAR (ADD1 SKIPEDLEN))
(CONS (CAR PAT)
TAIL)
NIL))
(T ('MATCHWM ['CDR (SETQ TEM1
(SUBSTVAR ('NTH VAR
('PLUS SKIPEDLEN
1]
(CONS (CAR PAT)
TAIL)
NIL]
[[NILPAT (SETQ TAIL (SKIP$ANY (CDR PAT]
(PROG (CHECKINGLENGTH)
(* If pat ends in (... -- & & &) then just match
(NLEFT var 3) against & & &; CHECKINGLENGTH = NIL will keep
a (NULL (CDDDR x)) check away)
[SETQ TEM1
(COND
[(OR (AND (REPLACED (CDR PAT))
(SETQ TEM2 (UNCDR VAR)))
(ZEROP SKIPEDLEN))
(* Check var::-skipedlen)
('CDR (SUBSTVAR ('NLEFT TEM2 ('PLUS
SKIPEDLEN 1)
NIL ZLENFLG]
(T (SUBSTVAR ('NLEFT VAR SKIPEDLEN NIL
ZLENFLG]
('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
('MATCHWM TEM1 (CDR PAT)
NIL)
(PATAPPLY* ('LDIFF VAR TEM1]
([AND (NULL FN)
(EQ TAIL (CDDR PAT))
(EQ SKIPEDLEN 1)
(NULLPAT? TAIL)
(EQ (CAADR PAT)
(QUOTE SUBPAT))
(OR (EQ (CAR PAT)
(QUOTE $))
(EVERY (CDDR (CADR PAT))
(FUNCTION ARB?)))
[COND
[(NLISTP (CADR (CADR PAT)))
(NOT (FMEMB (CADR (CADR PAT))
(QUOTE (& $ --]
(T (FMEMB (CAR (CADR (CADR PAT)))
(QUOTE (= == ']
(FMEMB [CAR (SETQ TEM1 ('MATCHELT
(QUOTE DUMMY)
(CADR (CADR PAT]
(QUOTE (EQ EQUAL EQP STREQUAL]
(* PAT: (-- (SUBPAT EQTYPE?
ARB?) --))
(PROG [TEM2
(VAR (LIST (SELECTQ (CAR TEM1)
(EQ (LOOK (QUOTE ASSOC)
VAR))
(QUOTE SASSOC))
(CADDR TEM1)
VAR))
(PAT (CONS (QUOTE &)
(CDDR (CADR PAT]
('MATCHSUBPAT (SUBSTVAR VAR)
PAT T)))
(T
(PROG ({OLD⎇ {FINALLY⎇EXPR {UNTIL⎇EXPR {ON⎇VAR
[INASOME (COND
((EQ (CAR PAT)
(QUOTE $))
(QUOTE FASTINASOME))
(T (QUOTE INASOME]
(WATCHPOSTPONELST (CONS (SETQ TEM1
(GENSYML))
WATCHPOSTPONELST)))
(* WATCHPOSTPONELST is reset so that postponed uses of it
can be detected; needed to set {OLD⎇)
(COND
((AND (REPLACED (CDR PAT))
(SETQ {ON⎇VAR (UNCDR VAR)))
(SETQ TEM2 ('CDR TEM1)))
(T (SETQ {ON⎇VAR VAR)
(SETQ TEM2 TEM1)))
(SETQ {UNTIL⎇EXPR ('MATCHWM TEM2 (CDR PAT)
NIL))
(SETQ {FINALLY⎇EXPR
('AND
(PATAPPLY* FN ('LDIFF VAR TEM2))
(OR [NOT (NULL (FMEMB INASOME
(QUOTE (INASOME
FASTINASOME]
INASOME)))
(SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST)
(QUOTE FOUND)))
(RETURN ('FOR {OLD⎇ TEM1 {ON⎇VAR {UNTIL⎇EXPR
{FINALLY⎇EXPR (CANMATCHNILLIST
(CDR PAT]
(RETURN ('MATCHELT1 VAR PAT FN]
((SELECTQ
(CAAR PAT)
((= == ' SUBPAT } *ANY*)
(* For now, }'s can only refer to = == ' and subpats , i.e.
elementary patterns)
(RETURN ('MATCHELT1 VAR PAT FN)))
[$< (* This matches a segment less
that a given length)
(* (FOR {TEM1⎇ ON {VAR⎇ AS {TEM2⎇ FROM {PAT:1::2⎇ TO 1 BY -1
DO (IF (MATCHES {TEM1⎇ {PAT::1⎇) THEN
(RETURN {FINALLY,SIDES⎇))))
(RETURN
(COND
((NILPAT (CDR PAT)) (* Pattern ends in --)
('AND ['NULL ('NTH VAR ('PLUS 1 (CDAR PAT]
(PATAPPLY* FN VAR)))
(INASOME [DOWATCH (SETQ INASOME
(PROG (INASOME)
(RETURN ('MATCHWM VAR PAT FN]
T)
(T
(PROG ((INASOME (QUOTE INASOME)))
(SUBPAIR
(QUOTE (TEM1 VAR CNT MTCH FINALLY))
[LIST (SETQ TEM1 (GENSYML))
VAR
(CDAR PAT)
('NOT ('MATCHWM TEM1 (CDR PAT)
NIL))
('AND (OR (EQ INASOME (QUOTE INASOME))
INASOME)
(PATAPPLY* FN ('LDIFF VAR TEM1]
(QUOTE (PROG ((TEM1 VAR)
($$CNT CNT))
$$RPTLP
(COND
((IMINUSP (SETQ $$CNT
(SUB1 $$CNT)))
(RETURN))
[MTCH (COND
((LISTP TEM1)
(SETQ TEM1
(CDR TEM1))
(GO $$RPTLP))
(T (RETURN]
(T (RETURN FINALLY]
($> (RETURN ('MATCHWM VAR
(CONS (LIST (QUOTE !)
(QUOTE SUBPAT)
(CONS (QUOTE $=)
('PLUS 1 (CDAR PAT)))
(QUOTE --))
(CDR PAT))
FN)))
[!
(RETURN
(COND
((NILPAT (CDR PAT))
('AND [COND
((EQ (CADAR PAT)
(QUOTE SUBPAT))
(* This isn't really a subpat and so don't rebind
CHECKINGLENGTH etc as in 'MATCHSUBPAT)
('MATCHWM VAR (CDDAR PAT)
NIL))
(T ('MATCHELT VAR (CDAR PAT]
(PATAPPLY* FN VAR)))
((NLISTP (CAR PAT))
(PATERR "Invalid '!'" PAT))
(T
(SELECTQ
(CADAR PAT)
[= (* !=)
('HEADPLOOP VAR (CDDAR PAT)
(SETQ TEM1 (BOUNDVAR))
(CANMATCHNILLIST (CDR PAT))
('AND (PATAPPLY* FN ('LDIFF VAR TEM1))
('MATCHWM TEM1 (CDR PAT)
NIL]
[==(COND
((NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
('MATCHWM VAR (LIST (CAR PAT))
FN)))
(T (PATERR (QUOTE !AT)
(CDAR PAT]
['(COND
[[OR (NLISTP (CDDAR PAT))
(CDR (LAST (CDDAR PAT]
(COND
((NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
('MATCHWM VAR (LIST (CAR PAT))
FN)))
(T (PATERR (QUOTE !AT)
(CDAR PAT]
(T
('MATCHWM
VAR
(CONS
[CONS
(QUOTE !)
(CONS (QUOTE SUBPAT)
(MAPCAR (CDDAR PAT)
(FUNCTION (LAMBDA (X)
(CONS (QUOTE ')
X]
(CDR PAT))
FN]
[SUBPAT
(* Use the *GLITCH kludge to get the whatmatched of the rest
of the thing)
(COND
((NULL FN)
('MATCHWM VAR (APPEND (CDDAR PAT)
(CDR PAT))
NIL))
(T
(PROG ((WMLST (CONS NIL WMLST)))
(RETURN
('AND
('MATCHWM
VAR
[APPEND
(CDDAR PAT)
(LIST
(CONS
(QUOTE *GLITCH)
(CONS
WMLST
(MAKE!PAT
(MAKESUBPAT (CDR PAT]
NIL)
(PATAPPLY* FN ('LDIFF VAR
(CAR WMLST]
(PATERR "Invalid use of ! in pattern" (CADAR PAT]
[$=(RETURN (COND
((NILPAT (CDR PAT))
('AND (OR (NOT CHECKINGLENGTH)
('EQLENGTH VAR (CDAR PAT)))
(PATAPPLY* FN VAR)))
[(AND (NULL FN)
(COND
([NULLPAT? (SETQ TAIL (SKIP$I
(CDR PAT]
[SETQ TEM2
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH
VAR
('PLUS (CDAR PAT)
SKIPEDLEN]
(COND
(INASOME (DOWATCH (SETQ INASOME TEM2))
T)
(T TEM2)))
((NULL TAIL)
('EQLENGTH VAR ('PLUS (CDAR PAT)
SKIPEDLEN]
((ZEROP (CDAR PAT))
('AND (PATAPPLY* FN ('LDIFF VAR VAR))
('MATCHWM VAR (CDR PAT)
NIL)))
(T [SETQ TEM1 (SUBSTVAR ('NTH VAR (CDAR PAT]
('AND (OR (NOT CHECKINGLENGTH)
(NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
(PATAPPLY* FN ('LDIFF VAR ('CDR TEM1)))
('MATCHWM ('CDR TEM1)
(CDR PAT)
NIL]
[@(COND
[[AND (CDR PAT)
(NOT (ELT? (CDDAR PAT]
(COND
[[AND (NULL FN)
(FMEMB (CDDAR PAT)
(QUOTE ($ --]
[SETQ TEM1 ('FOR (QUOTE OLD)
(SETQ TEM1 (GENSYML))
VAR
('AND ('APPLY* (CADAR PAT)
('LDIFF VAR TEM1))
('MATCHWM TEM1 (CDR PAT)
NIL))
T
(CANMATCHNILLIST (CDR PAT]
(COND
(INASOME (SETQ INASOME TEM1)
(RETURN T))
(T (RETURN TEM1]
([AND NIL (NULL (CDR PAT))
INASOME
(EQ (CAR FN 'TRUE))
(FMEMB (CDDAR PAT)
(QUOTE ($ --]
(* We are in a some, and trying to match agains
($@FOO) -
Don't need to check this tail more than once)
(DOWATCH (SETQ INASOME ('APPLY* (CADAR PAT)
VAR)))
(RETURN T))
(T
(RETURN
(PROG (INASOME)
('MATCHWM
VAR
[LIST
(CDDAR PAT)
(CONS (QUOTE @)
(CONS ('APPLY* (CADAR PAT)
('LDIFF
VAR
(QUOTE @)))
(MAKE!PAT
(MAKESUBPAT (CDR PAT]
FN]
((AND NIL (NLISTP (CADAR PAT))
(GETP (CADAR PAT)
(QUOTE NARGS))
(ELT? (CDDAR PAT)))
('AND ('APPLY* (CADAR PAT)
('CAR VAR))
('MATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
FN]
NIL))
(T (RETURN ('MATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
(CONS (FUNCTION 'MATCHWMFUNARG)
(CONS (CAR PAT)
FN])
('MATCHWMFUNARG
[LAMBDA (X ARGS)
('AND (SELECTQ (CAAR ARGS)
[<-(OR (CHECKSETQ X ARGS)
('SETQ (CADAR ARGS)
X
(CANMATCHNIL (CDDAR ARGS]
[←(OR (CHECKSETQ X ARGS)
(POSTPONEDSETQ (CADAR ARGS)
X
(CANMATCHNIL (CDDAR ARGS]
(-> ('REPLACE X (CADAR ARGS)))
(→ (POSTPONEDREPLACE X (CADAR ARGS)))
(@('APPLY* (CADAR ARGS)
X))
(*GLITCH (FRPLACA (CADAR ARGS)
X)
(DOWATCH X)
T)
(PATHELP "MATCH FUNARG MISMATCH" ARGS))
(SELECTQ (CADR ARGS)
(TRUE T)
(NIL T)
('MATCHWMFUNARG ('MATCHWMFUNARG X (CDDR ARGS)))
(PATAPPLY* (CDR ARGS)
X])
(CHECKSETQ
[LAMBDA (X ARGS)
(COND
((FMEMB (CADAR ARGS)
#LIST)
(MAKESUBST3 (CADAR ARGS)
X)
T)
((EQ (CADAR ARGS)
(QUOTE *))
(DOWATCH X)
(SETQ MUSTRETURN X)
T])
('MATCHELT1
[LAMBDA (VAR PAT FN)
('AND [OR (NOT CHECKINGLENGTH)
(COND
((CDR PAT)
(COND
((AND (CANMATCHNIL (CAR PAT))
(CANMATCHNILLIST (CDR PAT)))
VAR)
(T T)))
((CANMATCHNIL (CAR PAT))
('EQLENGTH VAR 1))
(T ('NULL ('CDR VAR]
('MATCHELT ('CAR VAR)
(CAR PAT))
(PATAPPLY* FN ('CAR VAR))
(OR (NULL (CDR PAT))
(COND
([AND (EQ INASOME (QUOTE FASTINASOME))
(COND
[(LISTP (CAR PAT))
(FMEMB (CAAR PAT)
(QUOTE (= == ' *ANY*]
(T (NOT (FMEMB (CAR PAT)
(QUOTE ($1 &]
(SETQ INASOME (PROG (INASOME)
('MATCHWM ('CDR VAR)
(CDR PAT)
NIL)))
T)
(T ('MATCHWM ('CDR VAR)
(CDR PAT)
NIL])
('MATCHELT
[LAMBDA (VAR PATELT) (* This function matches VAR
against PATELT when PATELT is a
pattern element)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($ -- &)
T)
('EQUAL VAR PATELT)))
(T (SELECTQ (CAR PATELT)
(==('EQ VAR (CDR PATELT)))
[*ANY*('OR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (X)
('MATCHELT VAR X]
[}('NOT ('MATCHELT VAR (CDR PATELT]
['('EQUAL VAR (KWOTE (CDR PATELT]
(=('EQUAL VAR (CDR PATELT)))
(SUBPAT ('MATCHSUBPAT VAR (CDR PATELT)))
($=(COND
[CHECKINGLENGTH (COND
(CHECKLENGTH ('EQLENGTH VAR
(CDR PATELT)))
(T ('NOTLESSPLENGTH VAR (CDR PATELT]
(T T)))
(PATHELP "MATCHELT invalid pattern"])
(PATAPPLY*
[LAMBDA (FNL ARG)
(AND FNL (BLKAPPLY* (CAR FNL)
ARG
(CDR FNL])
)
(DEFINEQ
(PATPARSE
[LAMBDA (PAT)
(OR (LISTP PAT)
(PATHELP "bad input" PAT))
(PROG (DEFAULTLST)
(PATPARSE1 PAT])
(PATPARSE1
[LAMBDA (PAT PREFIX) (* DECLARATIONS: UNDOABLE)
(PROG (TEM TEM2 TEM3 CARPAT CDRPAT NOTFOUND)
(OR PAT (RETURN))
RETRY
[AND (CDR PAT)
(NLISTP (CDR PAT))
(SETQ PAT (LIST (CAR PAT)
(QUOTE %.)
(CDR PAT]
(* Take care of (a . b) by changing it to
(a %. b))
[COND
[(LISTP (CAR PAT))
(SELECTQ
(CAAR PAT)
(*ANY*[SETQ CARPAT (CONS (CAAR PAT)
(PROG ((TOPPAT (CAR PAT)))
(PATPARSE1 (CDAR PAT]
(OR (EVERY CARPAT (FUNCTION SIMPLELT?))
(PATERR "*ANY*/*EVERY* construct too compicated" PAT))
(SETQ CDRPAT (CDR PAT)))
(QUOTE
(* This is so (-- (QUOTE A) --) means
(-- 'A --); this kludge is necessary now since DWIMIFY1B
sometimes parses the 'A into (QUOTE A))
[COND
[(NOT (ATOM (CADAR PAT)))
(/RPLNODE PAT (QUOTE ')
(CONS (CADAR PAT)
(CDR PAT]
(T (/RPLACA PAT (PACK (LIST (QUOTE ')
(CADAR PAT]
(GO RETRY))
[LAMBDA
(* (-- (LAMBDA (X) --) --) means
(-- &@ (LAMBDA (X) --)))
(/ATTACH (QUOTE &@)
PAT)
(GO RETRY]
(PROGN (* Otherwise, it's a
sub-pattern)
[SETQ CARPAT (MAKESUBPAT (PROG ((TOPPAT (CAR PAT)))
(PATPARSE1 (CAR PAT]
(SETQ CDRPAT (CDR PAT]
((NOT (LITATOM (CAR PAT))) (* Strings and numbers parse to
themselves)
(OR (STRINGP (CAR PAT))
(NUMBERP (CAR PAT))
(PATERR (QUOTE BADELT)
(CAR PAT)))
(SETQ CARPAT (CAR PAT))
(SETQ CDRPAT (CDR PAT)))
((SETQ TEM (FASSOC (CAR PAT)
PATTERNITEMS))
(* If this is a pattern item; PATTERNITEMS is an association
list; with an entry being (iteminpattern parsing
smashpatwith))
(SETQ CARPAT (OR (CADR TEM)
(CAR TEM)))
(SETQ CDRPAT (CDR PAT)))
[(SETQ TEM (FASSOC (CAR PAT)
PATTERNPREFIXES))
(SETQ CDRPAT)
(* PATTERNPREFIXES is an association list of
(opr type form); opr is the 'OPERATOR'
(e.g. =); type is either PAT, T, or expr;
PAT means the next thing is a pattern
(as in !) and expr means the next thing is a lisp expression
(e.g. =))
(SETQ TEM3 T)
(SETQ TEM2 (SELECTQ (CADR TEM)
[EXPR (CAR (SETQ CDRPAT (PATGETEXPR
(CDR PAT)
PAT]
[PAT (CAR (SETQ TEM3 (PATPARSE1 (CDR PAT]
(CADR PAT)))
[SETQ CARPAT (COND
((LISTP (CADDR TEM))
(SUBST TEM2 (QUOTE HERE)
(CADDR TEM)))
(T (SELECTQ (CADDR TEM)
[$=(COND
((EQ TEM2 1)
(QUOTE &))
(T (CONS (QUOTE $=)
TEM2]
(NEGATEPAT (NEGATEPAT TEM2 PAT))
(MAKE!PAT (MAKE!PAT TEM2 TEM3 PAT PREFIX))
(BLKAPPLY* (CADDR TEM)
TEM2 TEM3 PAT PREFIX]
[COND
((NEQ TEM3 T)
(RETURN (CONS CARPAT (CDR TEM3]
(SETQ CDRPAT (COND
(CDRPAT (CDR CDRPAT))
(T (CDDR PAT]
((SETQ TEM (PATUNPACK PAT))
(SETQ PAT TEM)
(* Now, either we have a "DEFAULT" condition, or else a var
infix condition)
(GO RETRY))
(T (SETQ NOTFOUND PAT)
(SETQ CARPAT (CAR PAT))
(SETQ CDRPAT (CDR PAT]
(* By now, CARPAT is set to the parsing of the first thing
in PAT; and CDRPAT is the appropriate tail;
want to check for infix operators;
if NOTFOUND is non-nil, then CARPAT was an atom which wasn't
parseable as a pattern; might be a variable if followed by a
← or a # or a *)
REINFIX
(COND
((SETQ TEM (AND CDRPAT (FASSOC (CAR CDRPAT)
PATTERNREPLACEOPRS)))
[COND
[NOTFOUND
(* CARPAT is not a pattern, and followed by a ←;
want to know if the next thing is a pattern or something
else; it is assumed that var←pattern is meant;
I could change it to mean pat←var)
(TEST# CARPAT)
(SETQ TEM3 (PATPARSE1 (CDR CDRPAT)
CDRPAT))
(RETURN (CONS (CONS (CADR TEM)
(CONS CARPAT (CAR TEM3)))
(CDR TEM3]
(T (SETQ CARPAT (CONS (CADDR TEM)
(CONS [CAR (SETQ CDRPAT
(PATGETEXPR (CDR CDRPAT]
CARPAT)))
(SETQ CDRPAT (CDR CDRPAT]
(GO REINFIX))
(NOTFOUND (COND
(PREFIX (PATERR (COND
((STRPOSL CLISPCHARRAY (CAR PAT))
(QUOTE CLISP))
(T (QUOTE AMBIG)))
PAT)))
(SETQ PAT (PARSEDEFAULT PAT NIL PREFIX))
(SETQ NOTFOUND)
(GO RETRY))
((EQ (CAR CDRPAT)
(QUOTE @))
(SETQ CDRPAT (OR (PATUNPACKINFIX1 (CDR CDRPAT))
(CDR CDRPAT)))
(SETQ CARPAT (CONS (QUOTE @)
(CONS (PATGETFNNAME CDRPAT)
CARPAT)))
(SETQ CDRPAT (CDR CDRPAT))
(GO REINFIX))
((SETQ TEM (PATUNPACKINFIX CDRPAT))
(SETQ CDRPAT TEM)
(GO REINFIX)))
(RETURN (CONS CARPAT (PATPARSE1 CDRPAT])
(PARSEDEFAULT
[LAMBDA (PAT LOCALVARDEFAULT PREFIX)
(* Turns PAT:1 (which is a LITATOM) into the "DEFAULT"
pattern -
I.e. PAT:1 couldn't be parsed as a pattern -
It is assumed that the default for an atom is an element
pattern)
(OR (AND (LITATOM (CAR PAT))
(NEQ (CAR PAT)
T)
(CAR PAT))
(PATHELP "MAKEDEFAULT" (CAR PAT)))
(PROG (SMASHFLG NEWPAT)
(COND
((FMEMB (CAR PAT)
DEFAULTLST) (* Second occurance of a "DEFAULT"
is defaulted to =)
(SETQQ LOCALVARDEFAULT =))
([COND
((STRPOS "#" (CAR PAT)
1 NIL 1)
(OR [NUMBERP (PACK (CDR (DUNPACK (CAR PAT)
SKORLST3]
(PATERR (QUOTE BAD#)
PAT)))
((STRPOS "*" (CAR PAT))
(OR (EQ (CAR PAT)
(QUOTE *))
(PATERR (QUOTE BAD*)
PAT] (* #n is defaulted to ← the
first time)
(SETQQ LOCALVARDEFAULT SETQ))
((AND (NLISTP (CAR PAT))
(STRPOSL CLISPCHARRAY (CAR PAT)))
(PATERR (QUOTE CLISP)
PAT)))
RETRY
[SETQ NEWPAT
(SELECTQ
(OR LOCALVARDEFAULT (AND (NLISTP VARDEFAULT)
VARDEFAULT))
[(← SETQ SET)
(SETQ DEFAULTLST (CONS (CAR PAT)
DEFAULTLST))
(CONS (CAR PAT)
(CONS (QUOTE ←)
(CONS (QUOTE &)
(CDR PAT]
[(QUOTE ')
(COND
(SMASHFLG (/ATTACH (QUOTE ')
PAT))
(T (RETURN (CONS (QUOTE ')
PAT]
[(= EQUAL)
(COND
(SMASHFLG (/ATTACH (QUOTE =)
PAT))
(T (RETURN (CONS (QUOTE =)
PAT]
[(== EQ)
(COND
(SMASHFLG (/ATTACH (QUOTE ==)
PAT))
(T (RETURN (CONS (QUOTE ==)
PAT]
[(@ APPLY*)
(COND
(SMASHFLG (/ATTACH (QUOTE $1@)
PAT))
(T (RETURN (CONS (QUOTE $1)
(CONS (QUOTE @)
PAT]
(PROGN (SETQ SMASHFLG T)
[SETQ LOCALVARDEFAULT
(COND
(LOCALVARDEFAULT
(PATERR (COND
(VARDEFAULT "invalid PATTERNVARDEFAULT")
(T (QUOTE AMBIG)))
PAT))
((EQ 1 (GETP (CAR PAT)
(QUOTE NARGS)))
(SETQ SMASHFLG)
(QUOTE @))
((VARCHECK (CAR PAT)
T T T)
(QUOTE =))
((LISTP VARDEFAULT)
(CAR VARDEFAULT))
(T (QUOTE ?]
(GO RETRY]
(COND
(SMASHFLG (/RPLNODE2 PAT NEWPAT)
(RETURN PAT))
(T (RETURN NEWPAT])
(PATUNPACK
[LAMBDA (PAT)
(* THIS WOULD BE SIMPLER IF THERE WERNT THINGS LIKE $N
AROUND -- THIS FUNCTION UNPACKS
(CAR PAT) ALONG THE LINES OF PATTERN OPERATORS -
I'LL MAKE IT SIMPLER BY ASSUMING THAT THINGS ARE OK
(I.E. WILL UNPACK) (AND (STRPOSL PATTERNCHARRAY
(CAR PAT)) (PROG ((CHARS (DUNPACK
(CAR PAT) SKORLST2)) RESULTS) RETRY
(for CHR on CHARS do (for X in PATCHRLST bind TAIL do
(SETQ TAIL CHR) (COND ((for Z in
(CDR X) always (COND ((EQ Z (CAR TAIL))
(SETQ TAIL (CDR TAIL)) T))) (* CHARS IS
(... PATCHRSTRING ...); WE TAKE AND PUT ON RESULTS THE
UNPACKING OF THE FIRST AND REST)
(SETQ RESULTS (NCONC RESULTS (COND
((NEQ CHR CHARS) (LIST (PACK (LDIFF CHARS CHR))))
(T NIL)) (LIST (CAR X)))) (SETQ CHARS TAIL)
(GO RETRY))))) (AND RESULTS (NCONC1 RESULTS
(PACK CHARS)) (RETURN RESULTS)))))
(PATPARSEAT PAT PATCHARS])
(PATUNPACKINFIX
[LAMBDA (L)
(PATPARSEAT L PATTERNINFIXES1])
(PATGETFNNAME
[LAMBDA (L)
(OR (LISTP (CAR L))
(FGETD (CAR L))
(FIXSPELL (CAR L)
70 SPELLINGS2 T L (FUNCTION GETD)
T)
(FIXSPELL (CAR L)
70 USERWORDS T L (FUNCTION GETD)
T))
(CAR L])
(PATGETEXPR
[LAMBDA (L UP)
(OR L (PATERR "missing an expression" UP))
(SETQ L (OR (PATUNPACKINFIX L)
L))
(* THIS DOESN'T WORK, BUT I'LL KEEP THE IDEA HERE IN THIS
COMMENT (PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY1B L TOPPAT L T T FAULTFN)
(while (AND (NOT (PARSEABLE (CDR L)))
(DWIMIFY1B (CDR L) TOPPAT L T T FAULTFN)) do NIL)
(RETURN (CAR L))) -
WHERE PARSEABLE IS DEFINED AS (LAMBDA
(PATTERN) (OR (NLISTP PATTERN)
(NOT (LITATOM (CAR PATTERN))) (NULL
(CAR PATTERN)) (EQ (CAR PATTERN) T)
(FASSOC (CAR PATTERN) PATTERNITEMS)
(FASSOC (CAR PATTERN) PATTERNINFIXES)
(FASSOC (CAR PATTERN) PATTERNPREFIXES)
(AND (PATUNPACKINFIX PATTERN) (PARSEABLE PATTERN)))))
[COND
((LISTP (CAR L))
(PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY1B (CAR L)
(CAR L)
NIL NIL NIL FAULTFN]
L])
(PATPARSEAT
[LAMBDA (PAT CHRS)
(* Breaks apart (CAR PAT) if possible, replaces the parsing
into the beginning of PAT ; otherwise return NIL if can't -
CHRS is a list of args as if to STRPOS, i.e. check
(STRPOS X:1 PAT:1 1 NIL X:2) for X in CHRS -
X:1 is the char list, X:2 is ANCHOR)
(PROG (TEM DONEANYTHING LST POS)
(OR (AND (NLISTP (CAR PAT))
(STRPOSL PATTERNCHARRAY (CAR PAT)))
(RETURN))
(SETQ LST (DUNPACK (CAR PAT)
SKORLST3))
LP (COND
((NULL CHRS)
(RETURN))
((EQ (CADDR (CAR CHRS))
(CAR PAT))
(RETURN))
([NOT (SETQ POS (COND
[(NULL (CADAR CHRS))
(find X on LST suchthat (for Z in (CAAR CHRS)
as ZZ in X
always (EQ Z ZZ]
((for Z in (CAAR CHRS) as ZZ in LST always (EQ Z ZZ))
LST]
(SETQ CHRS (CDR CHRS))
(GO LP)))
(* Found one -
POS is now the tail of LST which begins with one of the
operators)
[SETQ PAT (CONS (CAR PAT)
(COND
([SETQ TEM (FNTH POS (ADD1 (FLENGTH (CAAR CHRS]
(CONS (PACK TEM)
(CDR PAT)))
(T (CDR PAT]
[SETQ TEM (COND
([AND TEM (EQ (CADDR (CAR CHRS))
(QUOTE $))
(NOT (FMEMB (CAR TEM)
(QUOTE (← @ = < >]
(QUOTE $=))
(T (CADDR (CAR CHRS]
(COND
[(NEQ POS LST)
(RPLNODE PAT (PACKLDIFF LST POS)
(CONS TEM (CDR PAT]
(T (FRPLACA PAT TEM)))
(RETURN PAT])
(MAKE!PAT
[LAMBDA (PATELT PATALL REALPAT PREFIX)
(COND
((AND (EQ (CAR REALPAT)
(QUOTE !))
(EQ PATELT (CAR PATALL))
(OR (EQ (CAR PATELT)
(QUOTE ←))
(EQ (CAR PATELT)
(QUOTE <-)))
(NOT (FMEMB (CADR PATELT)
DEFAULTLST)))
(* Change PATALL to ((← var ! subpat %.
all of it)) from ((← var . part1) part2))
[FRPLACD (CDR PATELT)
(MAKE!PAT (MAKESUBPAT (CONS (CDDR PATELT)
(CDR PATALL]
(FRPLACD PATALL NIL)
PATELT)
(T (OR (COND
((NLISTP PATELT)
(SELECTQ PATELT
(& (QUOTE $))
(($ --)
(QUOTE $))
NIL))
(T (SELECTQ (CAR PATELT)
(! (PATERR (QUOTE TWO!)
PATELT))
((← <- → -> @)
(FRPLACD (CDR PATELT)
(MAKE!PAT (CDDR PATELT)))
PATELT)
[* (CONS (CAR PATELT)
(MAKE!PAT (CDR PATELT]
(SUBPAT (AND (NULL (CDDR PATELT))
(NOT (ELT? (CADR PATELT)))
(CADR PATELT)))
($= PATELT)
NIL)))
(CONS (QUOTE !)
PATELT])
(MAKESUBPAT
[LAMBDA (PATLST)
(COND
((NULL PATLST)
NIL)
([OR (EQUAL PATLST (QUOTE (--)))
(EQUAL PATLST (QUOTE ($]
(QUOTE &))
(T (CONS (QUOTE SUBPAT)
PATLST])
(NEGATEPAT
[LAMBDA (PE REALPAT)
(OR (NLISTP PE)
(FMEMB (CAR PE)
(QUOTE (= == ' SUBPAT)))
(PATERR (QUOTE BADNOT)
REALPAT))
(CONS (QUOTE })
PE])
(PACKLDIFF
[LAMBDA (LST1 LST2)
(PROG (TEM1 TEM2)
(FRPLACD (OR (SETQ TEM1 (NLEFT LST1 1 LST2))
(HELP))
NIL)
(PROG1 (PACK LST1)
(FRPLACD TEM1 TEM2])
)
(DEFINEQ
(SKIP$I
[LAMBDA (PAT)
(* Returns to the first TAIL of PAT which doesn't begin with
a $i or a $$foo -
Sets the variable "LEN" to the total length of things
skipped over)
(SOME PAT (FUNCTION (LAMBDA (ELT)
(COND
((EQ ELT (QUOTE &))
(SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN))
NIL)
((EQ (CAR ELT)
(QUOTE $=))
(SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
NIL)
(T])
(SKIP$ANY
[LAMBDA (PAT)
(* Scans PAT until a pattern element which matches an
arbitrary length segment is hit -
Adds the length skipped to the variable SKIPEDLEN;
and sets ZLENFLG if finds any of zero length)
(SOME PAT (FUNCTION (LAMBDA (ELT TEM)
(COND
((NULL (SETQ TEM (PATLEN ELT)))
T)
((ZEROP TEM)
(SETQ ZLENFLG T)
NIL)
(T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM))
NIL])
(PATLEN
[LAMBDA (PATELT !ED)
(PROG NIL
LP (RETURN
(COND
[(NLISTP PATELT)
(SELECTQ PATELT
(($ --)
NIL)
(& (AND (NOT !ED)
1))
(COND
(!ED 0)
(T 1]
(T (SELECTQ (CAR PATELT)
(SUBPAT (COND
[!ED (for PE1 in (CDR PATELT) bind PLEN←0
finally (RETURN PLEN)
do (SETQ PLEN
('PLUS PLEN
(OR (PATLEN PE1)
(RETURN NIL]
(T 1)))
($=(CDR PATELT))
((← -> <- → @ *GLITCH)
(SETQ PATELT (CDDR PATELT))
(GO LP))
(! (SETQ PATELT (CDR PATELT))
(SETQ !ED T)
(GO LP))
(*ANY*(COND
(!ED NIL)
(T 1)))
('(COND
(!ED (LENGTH (CDR PATELT)))
(T 1)))
((= == }) (* Currently, } can only refer
to subpatterns, =, ==, and ')
(AND (NOT !ED)
1))
(($> $<)
NIL)
(PATHELP "PATLEN invalid pattern" PATELT])
($?
[LAMBDA (PATELT)
(OR (EQ PATELT (QUOTE --))
(EQ PATELT (QUOTE $])
(ELT?
[LAMBDA (PATELT)
(COND
[(NLISTP PATELT)
(OR (NUMBERP PATELT)
(STRINGP PATELT)
(FMEMB PATELT (QUOTE (& NIL T]
(T (SELECTQ (CAR PATELT)
((= == ' SUBPAT } *ANY*) (* Currently, } can only refer
to =, ==, ', and subpatterns)
T)
((← -> <- → @ *GLITCH)
(ELT? (CDDR PATELT)))
NIL])
(SIMPLELT?
[LAMBDA (PATELT)
(OR (NLISTP PATELT)
(SELECTQ (CAR PATELT)
(@(SIMPLELT? (CDDR PATELT)))
((← -> <- →)
NIL)
T])
(ARB?
[LAMBDA (PATELT @OKFLG)
(COND
((NLISTP PATELT)
($? PATELT))
(T (SELECTQ (CAR PATELT)
(! NIL)
(@ @OKFLG)
((<- → ← -> *GLITCH)
(ARB? (CDDR PATELT)@OKFLG))
NIL])
(NULLPAT?
[LAMBDA (PAT)
(COND
((NULL PAT)
(NOT CHECKLENGTH))
(T (EVERY PAT (FUNCTION $?])
(NILPAT
[LAMBDA (PATLIST)
(AND CHECKLENGTH (NULL PATLIST])
(CANMATCHNIL
[LAMBDA (PATELT)
(* Returns T if PATELT matches NIL, NIL if it doesn't, and
something ELSE (maybe) if it might
(e.g., =FOO))
(COND
((NLISTP PATELT)
(AND (FMEMB PATELT (QUOTE (& NIL $ --)))
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[@(AND (CANMATCHNIL (CDDR PATELT))
(NOT (FMEMB (CADR PATELT)
PATNONNILFUNCTIONS))
(QUOTE (MAYBE, MAYBE NOT]
(SUBPAT (CANMATCHNILLIST (CDR PATELT)))
($< T)
($=(OR (NOT (NUMBERP (CDR PATELT)))
(ILESSP (CDR PATELT)
1)))
($> NIL)
((← -> → <- *GLITCH)
(CANMATCHNIL (CDDR PATELT)))
(! (CANMATCHNIL (CDR PATELT)))
('(NULL (CDR PATELT)))
[(= ==)
(NOT (NEVERNIL (CDR PATELT]
(*ANY*(SOME (CDR PATELT)
(FUNCTION CANMATCHNIL)))
(}(CDR PATELT))
(PATHELP "CANMATCHNIL invalid pattern" PATELT)))
(T (PATHELP "CANMATCHNIL invalid pattern"])
(CANMATCHNILLIST
[LAMBDA (PATLIST)
(EVERY PATLIST (FUNCTION (LAMBDA (PE)
(AND (OR (NOT CHECKINGLENGTH)
(NOT (ELT? PE)))
(CANMATCHNIL PE])
(REPLACEIN
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(SELECTQ (CAR PATELT)
((-> → *GLITCH)
(* the *GLITCH might or might not be a replace, but can't
take any chances)
T)
((@ ← <-)
(REPLACEIN (CDDR PATELT)))
(! (REPLACEIN (CDR PATELT)))
(SUBPAT (SOME (CDR PATELT)
(FUNCTION REPLACEIN)))
(($= = == ' $< $> } *ANY*) (* All of these cannot be
pointing at a REPLACE)
NIL)
(PATHELP "Invalid pattern REPLACEIN" PATELT])
(REPLACED
[LAMBDA (PAT)
(for X in PAT do (COND
((ELT? X)
(RETURN))
((REPLACEIN X)
(RETURN T])
)
(DEFINEQ
(EASYTORECOMPUTE
[LAMBDA (EXPRESSION)
(* If the EXPRESSION is some cadddaars of a variable, return
that variable (something needs to check for VARS bound IN
somes and internal forms for WHEN it can't use it for the
*'s value))
(OR (AND (NLISTP EXPRESSION)
EXPRESSION)
(AND [OR (GETP (CAR EXPRESSION)
(QUOTE CROPS))
(FMEMB (CAR EXPRESSION)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPRESSION])
(TEST#
[LAMBDA (VAR) (* Check if VAR is a #n type
variable)
(COND
((FMEMB VAR #LIST))
((STRPOS "#" VAR 1 NIL 1)
(SETQ #LIST (CONS VAR #LIST])
(NEVERNIL
[LAMBDA (X)
(COND
[(LITATOM X)
(OR (EQ X T)
(AND X (NOT (COND
(PATVARSNILLOOKED PATVARSNIL)
(T (SETQ PATVARSNIL (VALUELOOKUP (QUOTE
PATVARSMIGHTBENIL]
(T (OR (NLISTP X)
(FMEMB (GETP (CAR X)
(QUOTE CLISPCLASS))
(QUOTE (+ * ↑ RPLACA RPLACD / - +-)))
(FMEMB (CAR X)
NEVERNILFUNCTIONS])
(FULLEXPANSION
[LAMBDA (X)
(PROG (TEM)
(COND
([OR (EQ (CAR X)
(QUOTE CAR))
(EQ (CAR X)
(QUOTE CDR))
(NULL (SETQ TEM (FASSOC (CAR X)
CRLIST]
X)
(T (LIST (CADDDR TEM)
(LIST (CAR (CDDDDR TEM))
(CADR X])
(GENSYML
[LAMBDA NIL
(OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(GENSYM])
(MAKESUBST
[LAMBDA (OLD NEW NOVARFLG)
(SETQ SUBLIST (CONS [CONS OLD (CONS NEW (NOT (NULL NOVARFLG]
SUBLIST))
OLD])
(MAKESUBST3
[LAMBDA (VAR VAL)
(DOWATCH VAR)
(DOWATCH VAL)
(MAKESUBST0 VAR VAL])
(MAKESUBST0
[LAMBDA (OLD NEW)
(MAKESUBST OLD NEW NIL])
(MAKESUBST1
[LAMBDA (OLD NEW)
(MAKESUBST OLD NEW (EASYTORECOMPUTE NEW])
(DOSUBST
[LAMBDA (EXPRESSION)
(* This function does the post substitution in the
EXPRESSION; it uses SUBLIST to substitute;
an entry in SUBLIST is (VAR NEWVALUE . FOUND) where FOUND is
initially NIL; when the VAR is found for the first time, the
FOUND field is smashed with a pointer to that place of
substitution; then if it is found again, the old place is
smashed with a (SETQ $$I VALUE) and then the newvalue is
made $$I, and "FOUND" is changed to T -
thus, if an expression occurs once, it is substituted
directly; more than once and (SETQ $$I -
) is put in the first place and $$I in the rest)
(OR (COND
[(NLISTP EXPRESSION)
(CAR (DOSUBST1 (LIST EXPRESSION]
(T (DOSUBST1 EXPRESSION)))
EXPRESSION])
(DOSUBST1
[LAMBDA (EXPRESSION)
(PROG (TEM1 TEM2)
(COND
((NLISTP EXPRESSION)
NIL)
[[SETQ TEM1 (find X in SUBLIST suchthat
(COND
[(NLISTP X)
(COND
((EQ X (CAR EXPRESSION))
(RETURN]
(T (EQ (CAR X)
(CAR EXPRESSION]
(* (CAR EXPRESSION) needs to be
substituted for)
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
(CDR EXPRESSION)))
[COND
((LISTP (CDDR TEM1)) (* We have already substituted
for it)
(SETQ TEM2 (BOUNDVAR))
(FRPLACA (CDDR TEM1)
('SETQ TEM2 (CADDR TEM1)))
(FRPLACA (CDR TEM1)
TEM2)
(FRPLACD (CDR TEM1)
T) (* Mark it that it's been found
twice)
)
((NULL (CDDR TEM1))
(* Haven't seen it before -
if CADR TEM1 is NLISTP this means that CAR TEM1 -> CADR TEM1
directly -
none of this SETQ jazz; so we put T there;
otherwise, we save EXPRESSION so that if TEM1:1 occurs again
we can go back and wrap setq around the computation of
TEM1:2)
(FRPLACD (CDR TEM1)
(COND
((NLISTP (CADR TEM1))
T)
(T EXPRESSION]
(FRPLACA EXPRESSION (CADR TEM1))
(* Might need to substitutions
within substituted EXPRESSION)
(COND
((NLISTP (CAR EXPRESSION))
(OR (DOSUBST1 EXPRESSION)
EXPRESSION))
(T (FRPLACA EXPRESSION (OR (DOSUBST1 (CAR EXPRESSION))
(CAR EXPRESSION)))
(FRPLACD EXPRESSION (OR (DOSUBST1 (CDR EXPRESSION))
(CDR EXPRESSION]
(T
(SELECTQ
(CAR EXPRESSION)
[LAMBDA
(* Don't want to substitute for lambda variables within the
lambda; this is so that the same variable can be used for a
some tail within the some and outside of it)
(PROG ((SUBLIST (APPEND (CADR EXPRESSION)
SUBLIST))
TEM)
(COND
((SETQ TEM (DOSUBST1 (CDDR EXPRESSION)))
(CONS (CAR EXPRESSION)
(CONS (CADR EXPRESSION)
TEM]
[PROG (PROG (V TEM FLG)
[SETQ V (MAPCAR
(CADR EXPRESSION)
(FUNCTION (LAMBDA (X)
(COND
([AND (LISTP X)
(SETQ TEM (DOSUBST1 (CDR X]
(SETQ FLG T)
(CONS (CAR X)
TEM))
(T X]
(PROG ((SUBLIST
(NCONC [MAPCAR (CADR EXPRESSION)
(FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X]
SUBLIST)))
(COND
((OR (SETQ TEM (DOSUBST1 (CDDR EXPRESSION)))
FLG)
(CONS (CAR EXPRESSION)
(CONS V (OR TEM (CDDR EXPRESSION]
(QUOTE NIL)
(PROG (A D)
(SETQ A (DOSUBST1 (CAR EXPRESSION)))
(SETQ D (DOSUBST1 (CDR EXPRESSION)))
(COND
((EQ (CAR EXPRESSION)
(QUOTE DUMMY))
(AND D (FRPLACD EXPRESSION D))
(RETURN)))
(AND (OR A D)
(CONS (OR A (CAR EXPRESSION))
(OR D (CDR EXPRESSION])
(FORMEXPAND
[LAMBDA (LIST AT)
(* Searches for (AT --) AT the top level of list and does a
(1) up (bo 1) on them)
[for X on LIST do (AND (EQ (CAAR X)
AT)
(FRPLACD X (NCONC (CDDAR X)
(CDR X)))
(FRPLACA X (CADAR X]
LIST])
(POSTPONEDREPLACE
[LAMBDA (VAR VALUE)
(DOWATCH VALUE)
(DOWATCH VAR)
(SETQ POSTPONEDRPLACS (CONS ('REPLACE VAR VALUE)
POSTPONEDRPLACS))
T])
(POSTPONEDSETQ
[LAMBDA (VARTOSET VALUE CANBENILFLG)
(DOWATCH VARTOSET)
(DOWATCH VALUE)
(SETQ POSTPONEDEFFECTS (CONS ('SETQ VARTOSET VALUE)
POSTPONEDEFFECTS))
(SETQ LASTEFFECTCANBENIL CANBENILFLG)
T])
(SUBSTVAR
[LAMBDA (EXPR)
(PROG (TEM)
(MAKESUBST0 (SETQ TEM (GENSYML))
EXPR)
(RETURN TEM])
(BOUNDVAR
[LAMBDA NIL
(BINDVAR (GENSYML])
(BINDVAR
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS))
VAR])
(SELFQUOTEABLE
[LAMBDA (EXPRESSION)
(OR (NUMBERP EXPRESSION)
(STRINGP EXPRESSION)
(NULL EXPRESSION)
(EQ EXPRESSION T])
(FINDIN0
[LAMBDA (VAR EXPR)
(OR (FINDIN1 VAR EXPR)
(SOME SUBLIST (FUNCTION (LAMBDA (X)
(AND (FINDIN1 (CAR X)
EXPR)
(FINDIN1 VAR (CDR X])
(FINDIN1
[LAMBDA (AT LST) (* CHEAP EDITFINDP)
(OR (EQ AT LST)
(AND (LISTP LST)
(OR (FINDIN1 AT (CAR LST))
(FINDIN1 AT (CDR LST])
(DOWATCH
[LAMBDA (EXPR)
(AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST (FUNCTION (LAMBDA (X)
(AND (NEQ (CAR X)
(QUOTE FOUND))
(FINDIN0 (CAR X)
EXPR)
(FRPLACA X (QUOTE FOUND])
(UNCROP
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
((GETP (CAR EXPR)
(QUOTE CROPS))
(UNCROP (CADR EXPR)))
(T (SELECTQ (CAR EXPR)
((CAR CDR NTH NLEFT LAST FLAST FNTH SOME)
(UNCROP (CADR EXPR)))
((MEMB FMEMB MEMBER)
(UNCROP (CADDR EXPR)))
EXPR])
(PATNARGS
[LAMBDA (X)
(OR (GETP X (QUOTE NARGS))
(NARGS X])
(UNCDR
[LAMBDA (VAR)
(AND (EQ (CAR (SETQ VAR (FULLEXPANSION VAR)))
(QUOTE CDR))
(CADR VAR])
(CHECKEASYVAR
[LAMBDA (VAR PAT)
(PROG (TEM)
(COND
((EASYTORECOMPUTE VAR)
VAR)
(T (COND
[[AND (REPLACED PAT)
(FMEMB (CAR (SETQ TEM (FULLEXPANSION VAR)))
(QUOTE (CAR CDR]
(LIST (CAR TEM)
(SUBSTVAR (CADR TEM]
(T (SUBSTVAR VAR])
)
(DEFINEQ
('NLEFT
[LAMBDA (EXPRESSION N TAIL NOTFASTFLG)
(COND
(TAIL (LIST (QUOTE NLEFT)
EXPRESSION N TAIL))
((ZEROP N) (* NO LOOKUP DONE SINCE FLAST
DOESN'T MAKE SENSE HERE)
(LIST (QUOTE CDR)
(LIST (QUOTE LAST)
EXPRESSION)))
[(EQ N 1)
(COND
(NOTFASTFLG (LIST (QUOTE LAST)
EXPRESSION))
(T ('LAST EXPRESSION]
(T (LIST (QUOTE NLEFT)
EXPRESSION N])
('NOT
[LAMBDA (X)
('NOT1 X (QUOTE NOT])
('NULL
[LAMBDA (X)
('NOT1 X (QUOTE NULL])
('NOT1
[LAMBDA (X FNNAME)
(COND
((NLISTP X)
(SELECTQ X
(NIL T)
(T NIL)
(LIST FNNAME X)))
(T (SELECTQ (CAR X)
((NOT NULL)
(CADR X))
(EQ (FRPLACA X (QUOTE NEQ)))
(NEQ (FRPLACA X (QUOTE EQ)))
[(OR AND)
(for Y on (CDR X) do (FRPLACA Y ('NOT1 (CAR Y)
FNNAME)))
(FRPLACA X (COND
((EQ (CAR X)
(QUOTE AND))
(QUOTE OR))
(T (QUOTE OR]
(LISTP (FRPLACA X (QUOTE NLISTP)))
(NLISTP (FRPLACA X (QUOTE LISTP)))
(LIST FNNAME X])
('NOTLESSPLENGTH
[LAMBDA (X N)
(COND
((ZEROP N)
T)
(T ('NTH X N])
('NTH
[LAMBDA (VAR LEN)
(COND
((OR (NOT (SMALLP LEN))
(ILESSP LEN 1)
(IGREATERP LEN MAXCDDDDRS))
(LIST (COND
(CHECKINGLENGTH (LOOK (QUOTE NTH)))
(T (QUOTE FNTH)))
VAR LEN))
(T (PROG NIL
LP (COND
((EQ LEN 1)
VAR)
((EQ LEN 2)
(LIST (QUOTE CDR)
VAR))
((EQ LEN 3)
(LIST (QUOTE CDDR)
VAR))
((EQ LEN 4)
(LIST (QUOTE CDDDR)
VAR))
((EQ LEN 5)
(LIST (QUOTE CDDDDR)
VAR))
(T (WHILE (IGREATERP LEN 5) DO (SETQ VAR (LIST (QUOTE CDDDDR)
VAR))
(SETQ LEN (IDIFFERENCE LEN 4)))
(GO LP])
('OR
[LAMBDA (LISTOFEXPRESSIONS)
(COND
[(CDR LISTOFEXPRESSIONS)
(CONS (QUOTE OR)
(FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR]
(T (CAR LISTOFEXPRESSIONS])
('PLUS
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (PROG ((SUM 0)
(LST (FORMEXPAND (LIST EXPR1 EXPR2)
(QUOTE IPLUS)))
VAL)
[FOR X in LST do (COND
((NUMBERP X)
(SETQ SUM (IPLUS X SUM)))
(T (SETQ VAL (NCONC1 VAL X]
(COND
((NULL VAL) SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM VAL)))
((NULL (CDR VAL))
(CAR VAL))
(T (CONS (QUOTE IPLUS)
VAL])
('REPLACE
[LAMBDA (VAR EXPRESSION)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQUAL VAR EXPRESSION)
T)
((EQ (CAR VAR)
(QUOTE CAR))
(LOOKLIST (QUOTE RPLACA)
(CADR VAR)
EXPRESSION))
((EQ (CAR VAR)
(QUOTE CDR))
(LOOKLIST (QUOTE RPLACD)
(CADR VAR)
EXPRESSION))
[(EQ (CAR VAR)
(QUOTE LDIFF))
('REPLACE (CADR VAR)
('NCONC EXPRESSION (CADDR VAR]
[(COND
((EQ (CAR EXPRESSION)
(QUOTE CONS))
T)
((EQ (CAR EXPRESSION)
(QUOTE LIST))
[COND
((CDDR EXPRESSION)
(SETQ EXPRESSION (LIST NIL (CADR EXPRESSION)
(CONS (QUOTE LIST)
(CDDR EXPRESSION]
T))
('PROGN (LIST ('REPLACE (LIST (QUOTE CAR)
VAR)
(CADR EXPRESSION))
('REPLACE (LIST (QUOTE CDR)
VAR)
(CADDR EXPRESSION]
(T (LOOKLIST (QUOTE RPLNODE2)
VAR EXPRESSION])
('SETQ
[LAMBDA (VAR EXPRESSION PROGNFLG)
(SETQ EXPRESSION (LIST (QUOTE SETQ)
VAR EXPRESSION))
(COND
(PROGNFLG (LIST (QUOTE PROGN)
EXPRESSION T))
(T EXPRESSION])
('AND
[LAMBDA N
(PROG ((NARGS N)
EXPR1 EXPR2)
(SETQ EXPR2 (ARG N NARGS))
LP (SETQ NARGS (SUB1 NARGS))
(COND
((ZEROP NARGS)
(RETURN EXPR2)))
(SETQ EXPR1 (ARG N NARGS))
(SETQ EXPR2 ('AND2 EXPR1 EXPR2))
(GO LP])
('AND2
[LAMBDA (EXPR1 EXPR2) (* DECLARATIONS: FAST)
(PROG (TEM)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
((EQUAL EXPR1 EXPR2)
EXPR2)
((EQUALUNCROP EXPR1 EXPR2)
EXPR2)
((EQ (CAR EXPR1)
(QUOTE PROGN))
(SETQ TEM (FLAST EXPR1))
(FRPLACA TEM ('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE COND))
(NOT (CDDR EXPR2)))
(FRPLACA (CADR EXPR2)
('AND EXPR1 (CAADR EXPR2)))
EXPR2)
((AND (EQ (CAR EXPR1)
(QUOTE COND))
(NULL (CDDR EXPR1)))
(FRPLACA (SETQ TEM (FLAST (CADR EXPR1)))
('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR1)
(QUOTE LISTP))
(SETQ TEM (CHECKSLISTP EXPR1 EXPR2)))
TEM)
((AND (EQ (CAR EXPR2)
(QUOTE OR))
(EQ (CADDR EXPR2)
T))
(LIST (QUOTE COND)
(LIST EXPR1 (CADR EXPR2)
T)))
[(EQ (CAR EXPR2)
(QUOTE PROGN))
(LIST (QUOTE COND)
(CONS EXPR1 (CDR EXPR2]
[(EQ (CAR EXPR2)
(QUOTE AND))
(COND
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC EXPR1 (CDR EXPR2)))
(T (FRPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC1 EXPR1 EXPR2))
[(AND [OR (AND (EQ (CAR EXPR1)
(QUOTE SETQ))
(SETQ TEM EXPR1))
(AND (EQ (CAR EXPR1)
(QUOTE OR))
(EQ (CAADR EXPR1)
(QUOTE SETQ))
(EQ (CADDR EXPR1)
T)
(SETQ TEM (CADR EXPR1]
(COND
((EQ EXPR2 (CADR TEM))
TEM)
((AND (EQ (CAR EXPR2)
(QUOTE AND))
(EQ (CADR TEM)
(CADR EXPR2)))
(FRPLACA (CDR EXPR2)
TEM)
EXPR2]
([AND (EQ (CAR EXPR1)
(QUOTE PROG))
(FMEMB (CAR (SETQ TEM (NLEFT EXPR1 2)))
(QUOTE ($$LP $$SOMELP $$RPTLP]
[COND
((EQ [CAR (SETQ TEM (CAR (LAST (CAR (LAST (CADR TEM]
(QUOTE RETURN))
(RPLACA (CDR TEM)
('AND (CADR TEM)
EXPR2)))
(T (PATHELP (QUOTE AND]
EXPR1)
(T (LIST (QUOTE AND)
EXPR1 EXPR2])
('CAR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CAR)
X))
(T (LIST TEM (CADR X])
('CDR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CDR)
X))
(T (LIST TEM (CADR X])
('EQ
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NULL VAR))
((ZEROP EXPRESSION)
(LIST (QUOTE ZEROP)
VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
('EQLENGTH
[LAMBDA (VAR LEN)
(* THIS SHOULD REALLY TAKE (EQLENGTH
(CDDDR X) 10) AND TRANSLATE IT TO
(EQLENGTH X 13))
(SELECTQ (CAR (LISTP VAR))
(CDR ('EQLENGTH (CADR VAR)
('PLUS LEN 1)))
(CDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 2)))
(CDDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 3)))
(CDDDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 4)))
(COND
((ZEROP LEN)
('NULL VAR))
(T (LIST (QUOTE EQLENGTH)
VAR LEN])
('EQUAL
[LAMBDA (VAR EXPRESSION)
[COND
((AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(SELFQUOTEABLE (CADR EXPRESSION)))
(SETQ EXPRESSION (CADR EXPRESSION]
(COND
((NULL EXPRESSION)
('NULL VAR))
((EQ EXPRESSION T)
('EQ VAR EXPRESSION))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
((STRINGP EXPRESSION)
(QUOTE STREQUAL))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
('LAST
[LAMBDA (X)
(LIST (LOOK (QUOTE LAST)
X)
X])
('F/L
[LAMBDA (ARGS EXPR)
(DSUBST (CAR ARGS)
('CAR (CADR ARGS))
EXPR)
(LIST (QUOTE FUNCTION)
(COND
([AND (EQ (CADR EXPR)
(CAR ARGS))
(OR (AND (EQLENGTH EXPR 2)
(EQ (PATNARGS (CAR EXPR))
1))
(AND (EQ (PATNARGS (CAR EXPR))
1)
(EQLENGTH EXPR 3)
(EQ (CADDR EXPR)
(CADR ARGS]
(CAR EXPR))
(T (LIST (QUOTE LAMBDA)
ARGS EXPR])
('APPLY*
[LAMBDA (FNNAME VAR)
(COND
((OR (NLISTP FNNAME)
(EQ (CAR FNNAME)
(QUOTE LAMBDA)))
(LIST FNNAME VAR))
(T (SUBST VAR (QUOTE @)
FNNAME])
('HEADPLOOP
[LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP)
(* (FOR {TAILVAR⎇ ON {VAR⎇ BIND {TEMVAR⎇←{HEADLIST⎇ WHILE
{TAILVAR⎇:1 EQUALS {TEMVAR⎇:1 DO
(IF NIL={TEMVAR⎇←{TEMVAR⎇::1 THEN
(RETURN {AFTER⎇))))
(PROG (TEMVAR)
(SUBPAIR (QUOTE (TEMVAR AFTER VAR TAILVAR HEADLIST))
(LIST (SETQ TEMVAR (BOUNDVAR))
(COND
[(EQ AFTEREXP T)
('OR (LIST ('NULL TEMVAR)
('EQ TEMVAR TAILVAR]
((NOT CANNILFLG)
('AND ('NULL TEMVAR)
AFTEREXP))
(T ('AND ('OR (LIST ('NULL TEMVAR)
('EQ TEMVAR TAILVAR)))
AFTEREXP)))
VAR TAILVAR HEADLIST)
(QUOTE (PROG NIL
(SETQ TAILVAR VAR)
(SETQ TEMVAR HEADLIST)
$$LP(COND
((LISTP TEMVAR)
(COND
((AND (LISTP TAILVAR)
(EQUAL (CAR TAILVAR)
(CAR TEMVAR)))
(SETQ TAILVAR (CDR TAILVAR))
(SETQ TEMVAR (CDR TEMVAR))
(GO $$LP)))
(RETURN))
(T (RETURN AFTER])
('LDIFF
[LAMBDA (X Y)
(LIST (QUOTE LDIFF)
X Y])
('PROG
[LAMBDA (VARS STATEMENTS)
(COND
((AND (NULL (CDR STATEMENTS))
(EQ (CAAR STATEMENTS)
(QUOTE PROG)))
(RPLACA (CDAR STATEMENTS)
(APPEND (CADAR STATEMENTS)
VARS))
(CAR STATEMENTS))
(T (CONS (QUOTE PROG)
(CONS VARS STATEMENTS])
('NCONC
[LAMBDA (VAR1 VAR2)
(COND
((NULL VAR1)
VAR2)
(T (LOOKLIST (QUOTE NCONC)
VAR1 VAR2])
('FOR
[LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG)
(PROG (TEM1)
(AND (EQ {UNTIL⎇EXPR T)
(PATHELP " a SOME with null terminator"
(LIST {OLD⎇ I.V. {ON⎇VAR {FINALLY⎇EXPR)))
(AND NOSOMEFLG (GO DOPROG))
[SETQ TEM1 (OR (SELECTQ (CAR {UNTIL⎇EXPR)
(EQ (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(LOOKLIST (QUOTE MEMB)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR)))
(EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(LIST (QUOTE MEMBER)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR)))
NIL)
(LIST (QUOTE SOME)
{ON⎇VAR
('F/L (LIST (GENSYML)
I.V.)
{UNTIL⎇EXPR]
(RETURN (COND
[(OR {OLD⎇ (NEQ {FINALLY⎇EXPR T))
(MAKESUBST0 I.V. TEM1)
(* OLD on means that I.V. is going to be used later on.
Thus, we set up to substitute TEM1 for I.V.
later, and return I.V. now)
(RETURN (COND
((NEQ {FINALLY⎇EXPR T)
{FINALLY⎇EXPR)
(T I.V.]
(T TEM1)))
DOPROG
(RETURN
('PROG
(AND (NOT {OLD⎇)
(LIST (LIST I.V. {ON⎇VAR)))
(NCONC (AND {OLD⎇ (LIST ('SETQ (BINDVAR I.V.)
{ON⎇VAR)))
(LIST (QUOTE $$SOMELP)
(LIST (QUOTE COND)
(LIST ('NOT {UNTIL⎇EXPR)
[LIST (QUOTE COND)
(LIST ('LISTP I.V.)
('SETQ I.V. ('CDR I.V.))
(QUOTE (GO $$SOMELP]
(QUOTE (RETURN)))
(LIST T (LIST (QUOTE RETURN)
{FINALLY⎇EXPR])
('PROGN
[LAMBDA (EXPRLST)
(PROG (X)
(OR EXPRLST (RETURN T))
(SETQ EXPRLST (FORMEXPAND EXPRLST (QUOTE PROGN)))
(while (AND (CDR EXPRLST)
(NLISTP (CAR EXPRLST)))
do (SETQ EXPRLST (CDR EXPRLST)))
(SETQ X EXPRLST)
LP (COND
((CDDR X)
[COND
((NLISTP (CAR X))
(FRPLACA X (CADR X))
(FRPLACD X (CDDR X)))
(T (SETQ X (CDR X]
(GO LP)))
(RETURN (COND
((CDR EXPRLST)
(CONS (QUOTE PROGN)
EXPRLST))
(T (CAR EXPRLST])
('LISTP
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
)
(DEFINEQ
(PATERR
[LAMBDA (MSG AT)
(LISPXPRIN1
(SELECTQ
MSG
(CLISP
"The pattern matcher is confused by what it thinks is CLISP
within a pattern - please recode this pattern")
(BADNOT "Cannot negate a non-element pattern")
(TWO! "Two !'s in a row")
(BAD*"invalid *")
(BAD# "invalid #")
(BADELT "Pattern item not atom or list ")
(NOWITH "no WITH")
(AMBIG "ambiguous pattern")
(!AT "!atom in middle of pattern")
(OR MSG "bad pattern"))
T)
(LISPXTERPRI T)
(COND
(AT (LISPXPRIN1 " at: " T)
(LISPXPRINT AT T)))
(LISPXPRIN1 " in: " T)
(LISPXPRINT MATCHEXPRESSION T)
(ERROR!])
(PATHELP
[LAMBDA (MESS1 MESS2)
(LISPXPRIN1 "error in Pattern Match" T)
(LISPXTERPRI T)
(HELP MESS1 MESS2])
(LOOKLIST
[LAMBDA (FN ARG ARG')
(LIST (LOOK FN ARG ARG')
ARG ARG'])
(VALUELOOKUP
[LAMBDA (VAR)
(COND
(LOCALDECLARATION (CLISPLOOKUP0 VAR (CADR MATCHEXPRESSION)
NIL LOCALDECLARATION NIL (QUOTE VALUE)))
(T (CAR VAR])
(LOOK
[LAMBDA (FN ARG ARG')
(PROG (CLASS CLASSDEF (LISPFN (OR (GETP FN (QUOTE LISPFN))
FN)))
(COND
([AND LOCALDECLARATION (SETQ CLASSDEF (GETP FN (QUOTE CLISPCLASSDEF]
(CLISPLOOKUP0 FN ARG ARG' LOCALDECLARATION LISPFN
(GETP FN (QUOTE CLISPCLASS))
CLASSDEF))
(T LISPFN])
(VARCHECK
[LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG)
(* Checks if VAR is really a variable -
Used by MAKEDEFAULT to avoid bad parsings)
(OR (AND (LITATOM VAR)
(OR (FMEMB VAR VARS)
(NEQ (EVALV VAR)
(QUOTE NOBIND)))
VAR)
(AND (NOT NOMESSFLG)
(ERROR VAR "NOT A VARIABLE" T])
(TRUE
[LAMBDA NIL T])
)
(DEFINEQ
(CHECKSLISTP
[LAMBDA (EXPR1 EXPR2)
(COND
((EQ (CADR EXPR1)
EXPR2)
EXPR1)
[(NLISTP EXPR2)
(PROG ((TEM (FASSOC EXPR2 SUBLIST))
TEM2)
(RETURN (AND TEM (SETQ TEM2 (CHECKSLISTP EXPR1 (CADR TEM)))
(RPLACA (CDR TEM)
TEM2)
EXPR2]
([OR (GETP (CAR EXPR2)
(QUOTE CROPS))
(FMEMB (CAR EXPR2)
(QUOTE (CAR CDR FNTH FLAST)))
(AND (FMEMB (CAR EXPR2)
(QUOTE (EQUAL EQ STREQUAL EQP)))
(CADDR EXPR2)
(OR (SELFQUOTEABLE (CADDR EXPR2))
(AND (EQ (CAR (CADDR EXPR2))
(QUOTE QUOTE))
(CADR (CADDR EXPR2]
(COND
((SETQ EXPR1 (CHECKSLISTP EXPR1 (CADR EXPR2)))
(RPLACA (CDR EXPR2)
EXPR1)
EXPR2)))
((AND (EQ (CAR EXPR2)
(QUOTE NTH))
(OR (NOT (SMALLP (CADDR EXPR2)))
(ILESSP (CADDR EXPR2)
2)))
NIL)
((FMEMB (CAR EXPR2)
(QUOTE (NLEFT LAST SOME NTH LISTP)))
(COND
((EQUALUNCROP (CADR EXPR1)
(CADR EXPR2))
EXPR2)))
((FMEMB (CAR EXPR2)
(QUOTE (MEMB MEMBER ASSOC SASSOC)))
(AND (EQUALUNCROP (CADR EXPR1)
(CADDR EXPR2))
EXPR2))
((EQ (CAR EXPR2)
(QUOTE (FMEMB FASSOC)))
(COND
((SETQ EXPR1 (CHECKSLISTP EXPR1 (CADDR EXPR2)))
(RPLACA (CDDR EXPR2)
EXPR1)
EXPR2])
(EQUALUNCROP
[LAMBDA (EXPR1 EXPR2)
(COND
((EQUAL EXPR1 EXPR2)
T)
[(NLISTP EXPR2)
(PROG ((TEM (FASSOC EXPR2 SUBLIST)))
(RETURN (AND TEM (EQUALUNCROP EXPR1 (CADR TEM]
((GETP (CAR EXPR2)
(QUOTE CROPS))
(EQUALUNCROP EXPR1 (CADR EXPR2)))
(T (SELECTQ (CAR EXPR2)
((CAR CDR NTH NLEFT LAST FLAST FNTH SOME LISTP)
(EQUALUNCROP EXPR1 (CADR EXPR2)))
((MEMB FMEMB MEMBER ASSOC SASSOC FASSOC)
(EQUALUNCROP EXPR1 (CADDR EXPR2)))
NIL])
(PATUNPACKINFIX1
[LAMBDA (L)
(PATPARSEAT L PATTERNINFIXES1])
)
(DECLARE
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 'MATCHWMFUNARG
CHECKSETQ 'MATCHELT1 'MATCHELT PATPARSE PATPARSE1 PARSEDEFAULT
PATUNPACK PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT
MAKESUBPAT NEGATEPAT PACKLDIFF SKIP$I SKIP$ANY PATLEN $? ELT?
SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN
REPLACED EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML
MAKESUBST MAKESUBST0 MAKESUBST3 MAKESUBST1 DOSUBST DOSUBST1
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP PATNARGS UNCDR
CHECKEASYVAR 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL 'LAST 'F/L
'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR 'PROGN 'LISTP PATERR
PATHELP LOOKLIST LOOK VALUELOOKUP VARCHECK TRUE PATUNPACKINFIX1
EQUALUNCROP CHECKSLISTP (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS CRLIST MAXCDDDDRS PATNONNILFUNCTIONS
PATGENSYMVARS PATTERNITEMS PATTERNPREFIXES
PATTERNREPLACEOPRS PATTERNINFIXES PATTERNINFIXES1
PATTERNCHARRAY NEVERNILFUNCTIONS MATCHSTATS)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME CHECKINGLENGTH WMLST
LASTEFFECTCANBENIL POSTPONEDEFFECTS MUSTRETURN
BINDINGS GENSYMVARLIST SKIPEDLEN ZLENFLG
LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS
CHECKLENGTH #LIST PATVARSNILLOOKED PATVARSNIL
POSTPONEDRPLACS LISTPCHECK DEFAULTLST VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
(BLKAPPLYFNS TRUE 'MATCHWMFUNARG))
) (RPAQQ PATCHARS ((($ <)
T $<)
(($ >)
T $>)
(($ =)
T $=)
((')
T ')
((!)
T !)
((= =)
T ==)
((=)
T =)
((})
T })
((< -)
NIL <-)
((@)
NIL @)
((←)
NIL ←)
(($)
T $)))
(RPAQQ PATTERNINFIXES (((←)
T ←)
((< -)
T <-)
((@)
T @)))
(RPAQQ PATTERNINFIXES1 (((←)
NIL ←)
((< -)
NIL <-)
((@)
NIL @)))
(RPAQQ PATTERNREPLACEOPRS ((← ← →)
(←← <- ->)
(←!!←!← ← →)
(<- <- ->)))
[RPAQQ PATTERNITEMS ((&)
(--)
($$ --)
(T)
(NIL)
(&)
(--)
($)
($1 &)
($2 ($= . 2))
($3 ($= . 3))
($4 ($= . 4))
($5 ($= . 5))
($6 ($= . 6]
(RPAQQ PATTERNPREFIXES ((== EXPR (== . HERE))
(= EXPR (= . HERE))
(' T (' . HERE))
(! PAT MAKE!PAT)
(%. PAT MAKE!PAT)
($> EXPR ($> . HERE))
($< EXPR ($< . HERE))
($= EXPR $=)
(} PAT NEGATEPAT)))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
(CDR CADR CDDR CDR NIL)
(CDDDDR NIL NIL CDR CDDDR)
(CADDDR NIL NIL CAR CDDDR)
(CDDDR CADDDR CDDDDR CDR CDDR)
(CDADDR NIL NIL CDR CADDR)
(CAADDR NIL NIL CAR CADDR)
(CADDR CAADDR CDADDR CAR CDDR)
(CDDR CADDR CDDDR CDR CDR)
(CDDADR NIL NIL CDR CDADR)
(CADADR NIL NIL CAR CDADR)
(CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR)
(CAAADR NIL NIL CAR CAADR)
(CAADR CAAADR CDAADR CAR CADR)
(CADR CAADR CDADR CAR CDR)
(CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR)
(CDDAR CADDAR CDDDAR CDR CDAR)
(CDADAR NIL NIL CDR CADAR)
(CAADAR NIL NIL CAR CADAR)
(CADAR CAADAR CDADAR CAR CDAR)
(CDAR CADAR CDDAR CDR CAR)
(CDDAAR NIL NIL CDR CDAAR)
(CADAAR NIL NIL CAR CDAAR)
(CDAAR CADAAR CDDAAR CDR CAAR)
(CDAAAR NIL NIL CDR CAAAR)
(CAAAAR NIL NIL CAR CAAAR)
(CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQQ NEVERNILFUNCTIONS
(CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER IREMAINDER
LOGOR LOGAND LOGXOR))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP))
[RPAQ PATTERNCHARRAY (MAKEBITTABLE (NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS (QUOTE CAR]
(RPAQQ PATGENSYMVARS
(GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13
$$14 $$15 $$16 $$17))
(OR (NEQ (CAR (QUOTE MATCHSTATS))
(QUOTE NOBIND))
(SETQ MATCHSTATS))
(RPAQQ PATVARDEFAULT QUOTE)
(RPAQQ MAXCDDDDRS 5)
(RPAQ PATCHECKLENGTH T)
(RPAQ PATLISTPCHECK NIL)
(RPAQ PATVARSMIGHTBENIL T)
STOP